home *** CD-ROM | disk | FTP | other *** search
/ Deutsche Edition 1 / Deutsche Edition 1.iso / amok / 031-040 / amok32 / tetriz / megatetriz.imp < prev    next >
Text File  |  1993-11-04  |  9KB  |  397 lines
  1. DEFINITION MegaTetriz; END MegaTetriz.
  2.  
  3. IMPLEMENTATION MegaTetriz;
  4.  
  5. IMPORT I: Intuition,
  6.        g: Graphics,
  7.        e: Exec,
  8.        d: Dos,
  9.        r: Random,
  10.        au: Audio,
  11.        es: ExecSupport;
  12.  
  13. CONST
  14.   W = 30;   (* Spielfeldgröße *)
  15.   H = 20;
  16.   bw = 20;  (* Boxgröße *)
  17.   bh = 8;
  18.   w = bw*W; (* Fenstergröße *)
  19.   h = bh*H;
  20.  
  21. TYPE
  22.   LS = LONGSET;
  23.  
  24. VAR
  25.   S: ARRAY 7,4 OF LONGSET;  (* LONGSET = ARRAY 4,4 OF BOOLEAN *)
  26.   Feld: ARRAY W,H OF INTEGER;
  27.  
  28.   nw: I.NewWindow;
  29.   window: I.WindowPtr;
  30.  
  31.   rp: g.RastPortPtr;
  32.  
  33.   MyMsgPtr: I.IntuiMessagePtr;
  34.   MyMsg: I.IntuiMessage;
  35.  
  36.   Lines: INTEGER;
  37.   HiScore: INTEGER;
  38.  
  39. CONST  (* $DataChip+ *)
  40.   RectTable = "\x7F\x80";
  41.   RectTableSize = 2;
  42.   AllocationMap = "\x01\x08\x02\x04";
  43.  
  44. VAR
  45.   AllocPort: e.MsgPortPtr;
  46.   AllocIOB:  au.IOAudio;
  47.   AudioOpen: BOOLEAN;
  48.  
  49. (*-------------------------------------------------------------------------*)
  50.  
  51.  
  52. PROCEDURE Box(x,y,c: INTEGER);
  53.  
  54. BEGIN
  55.   IF (x>=0) AND (y>=0) THEN
  56.     g.SetAPen(rp,c);
  57.     x := x*bw; y := y*bh;
  58.     g.RectFill(rp,x+1,y+1,x+(bw-2),y+(bh-1));
  59.   END;
  60. END Box;
  61.  
  62.  
  63. PROCEDURE Collide(s: LONGSET; x,y: INTEGER): BOOLEAN;
  64.  
  65. VAR i,j: INTEGER;
  66.  
  67. BEGIN
  68.   IF (y<0) OR (x<0) THEN RETURN FALSE END;
  69.   i := 0;
  70.   REPEAT
  71.     j := 0;
  72.     REPEAT
  73.       IF 4*i+j IN s THEN
  74.         IF (x+j>=W) OR (y+i>=H) OR (Feld[x+j,y+i]#0) THEN RETURN TRUE END;
  75.       END;
  76.       INC(j);
  77.     UNTIL j=4;
  78.     INC(i);
  79.   UNTIL i=4;
  80.   RETURN FALSE;
  81. END Collide;
  82.  
  83.  
  84. PROCEDURE Add(s: LONGSET; x,y,c: INTEGER);
  85.  
  86. VAR i,j: INTEGER;
  87.  
  88. BEGIN
  89.   i := 0;
  90.   REPEAT
  91.     j := 0;
  92.     REPEAT
  93.       IF 4*i+j IN s THEN Feld[x+j,y+i] := c END;
  94.       INC(j);
  95.     UNTIL j=4;
  96.     INC(i);
  97.   UNTIL i=4;
  98. END Add;
  99.  
  100.  
  101. PROCEDURE Draw(s: LONGSET; x,y,c: INTEGER);
  102.  
  103. VAR i,j: INTEGER;
  104.  
  105. BEGIN
  106.   i := 0;
  107.   REPEAT
  108.     j := 0;
  109.     REPEAT
  110.       IF 4*i+j IN s THEN
  111.         CASE x+j OF 0..W-1: CASE y+i OF 0..H-1: Box(x+j,y+i,c) ELSE END ELSE END;
  112.       END;
  113.       INC(j);
  114.     UNTIL j=4;
  115.     INC(i);
  116.   UNTIL i=4;
  117. END Draw;
  118.  
  119.  
  120. PROCEDURE WriteInt(i: INTEGER);
  121.  
  122. VAR
  123.   s: ARRAY 4 OF CHAR;
  124.   c: INTEGER;
  125.  
  126. BEGIN
  127.   c := 0;
  128.   REPEAT
  129.     s[3-c] := CHR(30H + i MOD 10);
  130.     i := i DIV 10;
  131.     INC(c);
  132.   UNTIL c=4;
  133.   g.SetAPen(rp,1); g.SetBPen(rp,0); g.SetDrMd(rp,g.jam2);
  134.   g.Text(rp,ADR(s),4);
  135. END WriteInt;
  136.  
  137.  
  138. PROCEDURE CheckLine();
  139.  
  140. VAR
  141.   x,y,y2: INTEGER;
  142.   lines: ARRAY H OF INTEGER;
  143.   lcnt: INTEGER;
  144.  
  145. BEGIN
  146.   lcnt := 0;
  147.   y := 0;
  148.   REPEAT
  149.     x := 0;
  150.     LOOP
  151.       IF Feld[x,y]=0 THEN EXIT END;
  152.       INC(x);
  153.       IF x=W THEN lines[lcnt] := 8*y; INC(lcnt); EXIT END;
  154.     END;
  155.     INC(y);
  156.   UNTIL y=H;
  157.   IF lcnt#0 THEN
  158.  
  159.     INC(Lines,lcnt);
  160.     g.Move(rp,56,h+8); WriteInt(Lines);
  161.  
  162.     es.BeginIO(ADR(AllocIOB));
  163.     g.SetDrMd(rp,g.complement);
  164.     x := 0;
  165.     REPEAT
  166.       y := 0;
  167.       REPEAT
  168.         g.RectFill(rp,0,lines[y]+1,w-1,lines[y]+7);
  169.         INC(y);
  170.       UNTIL y=lcnt;
  171.       INC(x);
  172.       d.Delay(3);
  173.     UNTIL x=8;
  174.     g.SetDrMd(rp,g.jam1);
  175.     e.WaitIO(ADR(AllocIOB));
  176.  
  177.     y := 19; y2 := 19; DEC(lcnt);
  178.     WHILE y2>=0 DO
  179.       WHILE (lcnt>=0) AND (lines[lcnt]=8*y2) DO DEC(y2); DEC(lcnt) END;
  180.       x := 0;
  181.       REPEAT
  182.         Feld[x,y] := Feld[x,y2];
  183.         INC(x);
  184.       UNTIL x=W;
  185.       DEC(y); DEC(y2);
  186.     END;
  187.     WHILE y>=0 DO
  188.       x := 0;
  189.       REPEAT
  190.         Feld[x,y] := 0;
  191.         INC(x);
  192.       UNTIL x=W;
  193.       DEC(y)
  194.     END;
  195.     y := 0;
  196.     REPEAT
  197.       x := 0;
  198.       REPEAT
  199.         Box(x,y,Feld[x,y]);
  200.         INC(x);
  201.       UNTIL x=W;
  202.       INC(y);
  203.     UNTIL y=H;
  204.   END;
  205. END CheckLine;
  206.  
  207.  
  208. PROCEDURE Play(): BOOLEAN;  (* TRUE wenn Q gedrückt *)
  209.  
  210. VAR
  211.   Stein: INTEGER;
  212.   x,x2,y,y2,c: INTEGER;
  213.   TimeCnt: INTEGER;
  214.   Turn,NewTurn: INTEGER;
  215.  
  216. BEGIN
  217.   g.SetAPen(rp,0);
  218.   g.RectFill(rp,0,0,w,h);
  219.  
  220.   x := 0;
  221.   REPEAT
  222.     y := 0;
  223.     REPEAT
  224.       Feld[x,y] := 0;
  225.       INC(y);
  226.     UNTIL y=H;
  227.     INC(x);
  228.   UNTIL x=W;
  229.  
  230.   Lines := 0; TimeCnt := 0;
  231.  
  232.   REPEAT
  233.     Stein := r.RND(7); c := Stein MOD 3 + 1; Turn := 0;
  234.     x := W DIV 2 - 1; IF Stein=0 THEN DEC(x) END;
  235.     y := 0;
  236.     LOOP
  237.       IF Collide(S[Stein,Turn],x,y) THEN EXIT END;
  238.       Draw(S[Stein,Turn],x,y-1,0);
  239.       Draw(S[Stein,Turn],x,y,c);
  240.       LOOP
  241.         Draw(S[Stein,Turn],x,y,c);
  242.         IF TimeCnt>=300 THEN DEC(TimeCnt,300); EXIT END;
  243.         REPEAT
  244.           e.WaitPort(window.userPort);
  245.           MyMsgPtr := LONGINT(e.GetMsg(window.userPort));
  246.         UNTIL MyMsgPtr#NIL;
  247.         MyMsg := MyMsgPtr^;
  248.         e.ReplyMsg(MyMsgPtr);
  249.         IF I.intuiTicks IN MyMsg.class THEN INC(TimeCnt,30+Lines) END;
  250.         IF I.vanillaKey IN MyMsg.class THEN
  251.           Draw(S[Stein,Turn],x,y,0);
  252.           CASE MyMsg.code OF
  253.           ORD('4'):
  254.             IF (x>0) AND NOT Collide(S[Stein,Turn],x-1,y) THEN DEC(x) END |
  255.           ORD('5'):
  256.             NewTurn := (Turn + 1) MOD 4;
  257.             x2 := x; y2 := y;
  258.             IF Stein=0 THEN
  259.               IF ODD(Turn) THEN DEC(x2); INC(y2); ELSE INC(x2); DEC(y2) END;
  260.             END;
  261.             IF NOT Collide(S[Stein,NewTurn],x2,y2) THEN
  262.               Turn := NewTurn;
  263.               x := x2;
  264.               y := y2;
  265.             END |
  266.           ORD('6'):
  267.             IF NOT Collide(S[Stein,Turn],x+1,y) THEN INC(x) END |
  268.           ORD(' '):
  269.             LOOP
  270.               Draw(S[Stein,Turn],x,y,c);
  271.               IF Collide(S[Stein,Turn],x,y+1) THEN EXIT END;
  272.               d.Delay(1);
  273.               INC(y);
  274.               Draw(S[Stein,Turn],x,y-1,0);
  275.             END;
  276.             EXIT |
  277.           ORD('q'): RETURN TRUE |
  278.           ELSE END;
  279.         END;
  280.         IF I.closeWindow IN MyMsg.class THEN RETURN TRUE END;
  281.       END;
  282.       INC(y);
  283.     END;
  284.     IF y>0 THEN
  285.       Add(S[Stein,Turn],x,y-1,c);
  286.       CheckLine;
  287.     END;
  288.   UNTIL y=0;
  289.  
  290.   IF Lines>HiScore THEN HiScore := Lines END;
  291.  
  292.   d.Delay(30);
  293.  
  294.   RETURN FALSE;
  295. END Play;
  296.  
  297.  
  298. (*-------------------------------------------------------------------------*)
  299.  
  300.  
  301. BEGIN
  302.  
  303.   window := NIL; HiScore := 0; AllocPort := NIL; AudioOpen := FALSE;
  304.  
  305.   S[0,0] := LS{0..3};    S[0,1] := LS{0,4,8,12}; S[0,2] := LS{0..3};    S[0,3] := LS{0,4,8,12};
  306.   S[1,0] := LS{0..2,5};  S[1,1] := LS{0,4,5,8};  S[1,2] := LS{1,4..6};  S[1,3] := LS{1,4,5,9};
  307.   S[2,0] := LS{0..2,4};  S[2,1] := LS{0,4,8,9};  S[2,2] := LS{2,4..6};  S[2,3] := LS{0,1,5,9};
  308.   S[3,0] := LS{0..2,6};  S[3,1] := LS{0,1,4,8};  S[3,2] := LS{0,4..6};  S[3,3] := LS{1,5,8,9};
  309.   S[4,0] := LS{0,1,5,6}; S[4,1] := LS{1,4,5,8};  S[4,2] := LS{0,1,5,6}; S[4,3] := LS{1,4,5,8};
  310.   S[5,0] := LS{1,2,4,5}; S[5,1] := LS{0,4,5,9};  S[5,2] := LS{1,2,4,5}; S[5,3] := LS{0,4,5,9};
  311.   S[6,0] := LS{0,1,4,5}; S[6,1] := LS{0,1,4,5};  S[6,2] := LS{0,1,4,5}; S[6,3] := LS{0,1,4,5};
  312.  
  313. (*------  Open Audio-Device:  ------*)
  314.  
  315.   AllocPort := es.CreatePort(NIL,0);
  316.   IF AllocPort=NIL THEN HALT(0) END;
  317.  
  318.   AllocIOB.request.message.node.pri  := -40;
  319.   AllocIOB.request.message.replyPort := AllocPort;
  320.   AllocIOB.data   := ADR(AllocationMap);
  321.   AllocIOB.length := 4;
  322.  
  323.   IF (e.OpenDevice(ADR("audio.device"),0,ADR(AllocIOB),0)#0) OR
  324.      (AllocIOB.request.error = au.allocFailed)
  325.   THEN HALT(0) END;
  326.  
  327.   AudioOpen := TRUE;
  328.  
  329.   AllocIOB.request.command := e.write;
  330.   AllocIOB.request.flags   := SHORTSET{4};
  331.   AllocIOB.data            := ADR(RectTable);
  332.   AllocIOB.length          := RectTableSize;
  333.   AllocIOB.period          := 4000;
  334.   AllocIOB.cycles          := 200;
  335.   AllocIOB.volume          := 64;
  336.  
  337. (*------  Open Window:  ------*)
  338.  
  339.   nw.leftEdge   := (g.gfx.normalDisplayColumns - (w+ 8)) DIV 2;
  340.   nw.topEdge    := (g.gfx.normalDisplayRows    - (h+24)) DIV 2;
  341.   nw.blockPen   := 1;
  342.   nw.width      := w+8;
  343.   nw.height     := h+24;
  344.   nw.idcmpFlags := LONGSET{I.closeWindow,I.vanillaKey,I.intuiTicks};
  345.   nw.flags      := LONGSET{I.windowClose,I.windowDepth,I.windowDrag,I.gimmeZeroZero,I.activate};
  346.   nw.screen     := NIL;
  347.   nw.type       := {I.wbenchScreen};
  348.   nw.title      := ADR("MegaTetriz");
  349.   window := I.OpenWindow(nw);
  350.   IF window=NIL THEN HALT(0) END;
  351.   rp := window.rPort;
  352.  
  353. (*------  Start:  ------*)
  354.  
  355.   LOOP
  356.  
  357.     g.SetAPen(rp,0); g.SetDrMd(rp,g.jam1);
  358.     g.RectFill(rp,0,0,w,h);
  359.     g.SetAPen(rp,1);
  360.  
  361.     g.Move(rp, 20,20);  g.Text(rp,ADR("S = Start"),9);
  362.     g.Move(rp, 20,40);  g.Text(rp,ADR("Q = Quit" ),8);
  363.     g.Move(rp, 20,60);  g.Text(rp,ADR("© 1989 by F. Siebert"),20);
  364.     g.Move(rp, 20,80);  g.Text(rp,ADR("   AMOK Stuttgart"),17);
  365.     g.Move(rp,  0,h+8); g.Text(rp,ADR("Lines:"   ),6);
  366.     g.Move(rp,108,h+8); g.Text(rp,ADR("Hi:"      ),3);
  367.     g.Move(rp,144,h+8); WriteInt(HiScore);
  368.  
  369.     REPEAT
  370.       REPEAT
  371.         e.WaitPort(window.userPort);
  372.         MyMsgPtr := LONGINT(e.GetMsg(window.userPort));
  373.       UNTIL MyMsgPtr#NIL;
  374.       MyMsg := MyMsgPtr^;
  375.       e.ReplyMsg(MyMsgPtr);
  376.     UNTIL LONGSET{I.intuiTicks}#MyMsg.class;
  377.  
  378.     IF I.vanillaKey IN MyMsg.class THEN
  379.       CASE MyMsg.code OF
  380.       ORD('s'): IF Play() THEN EXIT END |
  381.       ORD('q'): EXIT |
  382.       ELSE END;
  383.     ELSIF I.closeWindow IN MyMsg.class THEN
  384.       EXIT
  385.     END;
  386.  
  387.   END;
  388.  
  389. CLOSE
  390.  
  391.   IF window#NIL    THEN I.CloseWindow(window)        END;
  392.   IF AudioOpen     THEN e.CloseDevice(ADR(AllocIOB)) END;
  393.   IF AllocPort#NIL THEN es.DeletePort(AllocPort)     END;
  394.  
  395. END MegaTetriz.
  396.  
  397.